home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / Bonus / Plasmatech / ptscp_examples.exe / %MAINDIR% / Examples / Demo / FMain.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-08-31  |  26.4 KB  |  841 lines
  1. unit FMain; // Copyright ⌐ 1996-2001 Plasmatech Software Design. All rights reserved.
  2. {
  3.  Shell Control Pack - Demo Program
  4.  Version 1.6
  5.  
  6.  This file is part of the Shell Control Pack demonstration program.
  7.  It implements the main tabbed form.
  8.  
  9.  History
  10.  ===================================================================================================
  11.  V1.6   2Jul01 Delphi 6 release. No changes.
  12.  V1.5c 30Mar01 No changes.
  13.  V1.5b 12Dec00 No changes.
  14.  V1.5a 14May00 No changes.
  15.  V1.5   3Mar00 C++Builder 5 release.
  16.  V1.4a  5Nov99 No changes.
  17.  V1.4  14Sep99 Delphi 5 release. No changes.
  18.  V1.3h 29Mar99 No changes.
  19.  V1.3g  1Dec98 No changes.
  20.  V1.3f 12Jul98 Delphi 4 release. No changes.
  21.  V1.3e 22Apr98 No changes.
  22.  V1.3d 18Apr98 No changes.
  23.  V1.3c 16Mar98 No changes.
  24.  V1.3b  7Feb98 No changes.
  25.  V1.3a  7Jan98 Added hints to toolbar image.
  26.  V1.3  28Nov97 Added internationalisation code.
  27.  V1.2b 12Oct97 No changes.
  28.  V1.2a  5Oct97 No significant changes.
  29.  V1.2   6Sep97 Added aCD.Canvas example to PTTreeView1CustomDraw method.
  30.  V1.1a  6Jul97 No changes.
  31.  V1.1  26Jun97 Added palette support for welcome page.
  32.                Added scrollboxes to the splitter demo.
  33.                Added Custom Draw Tree page.
  34.  V1.0c 31May97 No significant changes.
  35.  V1.0b 17May97 Minor fixes and Delphi 3 support.
  36.  V1.0a  1May97 No significant changes.
  37.  V1.0  21Apr97 Released version 1.0
  38. }
  39.  
  40. {$INCLUDE PTCompVer.inc}
  41.  
  42. {$RANGECHECKS OFF} {$OVERFLOWCHECKS OFF} {$WRITEABLECONST OFF}
  43. {$BOOLEVAL OFF}    {$EXTENDEDSYNTAX ON}  {$TYPEDADDRESS ON}
  44.  
  45. interface
  46. uses
  47.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  48.   StdCtrls, ComCtrls, ExtCtrls, Buttons, Ole2, Menus,
  49.     UPTSplitter, UPTShellControls, UPTShell95, UPTShellUtils, UPTImageCombo,
  50.     FPTOpenDlg, FPTFolderBrowseDlg, UPTTreeList, UPTFrame;
  51.  
  52.  
  53. type TMaxLogPalette = packed record
  54.        palVersion: Word;
  55.        palNumEntries: Word;
  56.        palPalEntry: array [Byte] of TPaletteEntry;
  57.      end;
  58.      PMaxLogPalette = ^TMaxLogPalette;
  59.  
  60. // Type used to store data with the tree on the "Custom Draw Tree" page.
  61. type TTvData = class
  62.        private
  63.          mFont: TFont;
  64.          mBkColor: TColor;
  65.          procedure SetFont( aValue: TFont );
  66.        public
  67.          constructor Create( aFont: TFont;  aColor: TColor );
  68.          destructor Destroy; override;
  69.          property Font: TFont read mFont write SetFont;
  70.          property BkColor: TColor read mBkColor write mBkColor;
  71.      end;
  72.  
  73. type
  74.   TFrmMain = class(TForm)
  75.     PageControl1: TPageControl;
  76.     ExplorerTsh: TTabSheet;
  77.     Button1: TButton;
  78.     SplitterTsh: TTabSheet;
  79.     PTSplitter3: TPTSplitter;
  80.     PTSplitter4: TPTSplitter;
  81.     Label2: TLabel;
  82.     PTSplitter5: TPTSplitter;
  83.     Label3: TLabel;
  84.     ListTsh: TTabSheet;
  85.     WelcomeTsh: TTabSheet;
  86.     PaintBox1: TPaintBox;
  87.     Label1: TLabel;
  88.     Label4: TLabel;
  89.     VersionTxt: TLabel;
  90.     Panel1: TPanel;
  91.     PlasmaLogoImg: TImage;
  92.     Label6: TLabel;
  93.     Label7: TLabel;
  94.     Label8: TLabel;
  95.     Button3: TButton;
  96.     Button5: TButton;
  97.     Button6: TButton;
  98.     Button8: TButton;
  99.     Button9: TButton;
  100.     Label9: TLabel;
  101.     OpenDialogTsh: TTabSheet;
  102.     FolderBrowseTsh: TTabSheet;
  103.     OverviewTsh: TTabSheet;
  104.     Button7: TButton;
  105.     Button4: TButton;
  106.     Button11: TButton;
  107.     Button12: TButton;
  108.     Edit1: TEdit;
  109.     Label10: TLabel;
  110.     TestOpenDlgBtn: TButton;
  111.     Button14: TButton;
  112.     Button15: TButton;
  113.     Button16: TButton;
  114.     Button17: TButton;
  115.     Label11: TLabel;
  116.     PTShellList1: TPTShellList;
  117.     PTOpenDlg1: TPTOpenDlg;
  118.     OverviewRchtxt: TRichEdit;
  119.     ExplorerRchtxt: TRichEdit;
  120.     FileOpenRchedt: TRichEdit;
  121.     TabSheet8: TTabSheet;
  122.     UppercaseEdt: TEdit;
  123.     Label14: TLabel;
  124.     Label15: TLabel;
  125.     GetDisplayEdt: TEdit;
  126.     Button18: TButton;
  127.     Button19: TButton;
  128.     ShellGetDisplayPathnameRchedt: TRichEdit;
  129.     FolderBrowseRchedt: TRichEdit;
  130.     ToolbarImg: TImage;
  131.     PTFolderBrowseDlg1: TPTFolderBrowseDlg;
  132.     FolderBrowseBtn: TButton;
  133.     TabSheet4: TTabSheet;
  134.     ImageComboRchedt: TRichEdit;
  135.     Button2: TButton;
  136.     Button20: TButton;
  137.     PTImageCombo1: TPTImageCombo;
  138.     PTImageCombo2: TPTImageCombo;
  139.     Button13: TButton;
  140.     PTSaveDlg1: TPTSaveDlg;
  141.     OrderTsh: TTabSheet;
  142.     Button21: TButton;
  143.     Button22: TButton;
  144.     OrderBtn: TButton;
  145.     Button23: TButton;
  146.     OrderRchedt: TRichEdit;
  147.     PTTreeTsh: TTabSheet;
  148.     PTTreeView1: TPTTreeView;
  149.     FontBtn: TButton;
  150.     Timer1: TTimer;
  151.     EnableTimerBtn: TSpeedButton;
  152.     CustomDrawTreeRchedt: TRichEdit;
  153.     Button24: TButton;
  154.     Button25: TButton;
  155.     ClickMe1Btn: TButton;
  156.     BoldBtn: TSpeedButton;
  157.     ItalicBtn: TSpeedButton;
  158.     UnderlineBtn: TSpeedButton;
  159.     ScrollBox1: TScrollBox;
  160.     Image3: TImage;
  161.     ScrollBox2: TScrollBox;
  162.     Image1: TImage;
  163.     ResetBtn: TButton;
  164.     PopupMenu1: TPopupMenu;
  165.     LargeIconsMitm1: TMenuItem;
  166.     SmalliconsMItm1: TMenuItem;
  167.     ListMitm1: TMenuItem;
  168.     DetailsMitm1: TMenuItem;
  169.     FontDialog1: TFontDialog;
  170.     FgColorBtn: TButton;
  171.     BkColorBtn: TButton;
  172.     ColorDialog1: TColorDialog;
  173.     BaseBtn: TButton;
  174.     BaseTxt: TLabel;
  175.     Button10: TButton;
  176.     procedure Button1Click(Sender: TObject);
  177.     procedure PaintBox1Paint(Sender: TObject);
  178.     procedure OnNextBtnClick(Sender: TObject);
  179.     procedure OnBackBtnClick(Sender: TObject);
  180.     procedure Button10Click(Sender: TObject);
  181.     procedure FormCreate(Sender: TObject);
  182.     procedure TestOpenDlgBtnClick(Sender: TObject);
  183.     procedure FolderBrowseBtnClick(Sender: TObject);
  184.     procedure PTFolderBrowseDlg1SelChange(aSender: TObject; aNewSel: PItemIDList);
  185.     procedure Button13Click(Sender: TObject);
  186.     procedure OrderBtnClick(Sender: TObject);
  187.     procedure FormDestroy(Sender: TObject);
  188.     procedure EnableTimerBtnClick(Sender: TObject);
  189.     procedure Timer1Timer(Sender: TObject);
  190.     procedure BoldBtnClick(Sender: TObject);
  191.     procedure ItalicBtnClick(Sender: TObject);
  192.     procedure UnderlineBtnClick(Sender: TObject);
  193.     procedure PTTreeView1Deletion(Sender: TObject; Node: TTreeNode);
  194.     procedure ClickMe1BtnClick(Sender: TObject);
  195.     procedure ResetBtnClick(Sender: TObject);
  196.     procedure ViewMitmClick(Sender: TObject);
  197.     procedure FontBtnClick(Sender: TObject);
  198.     procedure FgColorBtnClick(Sender: TObject);
  199.     procedure BkColorBtnClick(Sender: TObject);
  200.     procedure PTTreeView1Change(Sender: TObject; Node: TTreeNode);
  201.     procedure BaseBtnClick(Sender: TObject);
  202.     procedure ToolbarImgMouseMove(Sender: TObject; Shift: TShiftState; X,
  203.       Y: Integer);
  204.     procedure PTTreeView1NodeContextMenu(aSender: TObject;
  205.       aNode: TTreeNode; var aPos: TPoint; var aMenu: TPopupMenu);
  206.     procedure PTTreeView1PTCustomDraw(aSender: TObject; aCD: TPTCustomDraw;
  207.       aNode: TTreeNode);
  208.   private
  209.     procedure LoadRtf( rtf: TRichEdit;  id: Integer );
  210.   protected // -- Palette support -----
  211.     mhPal: HPALETTE;
  212.     mPalStruct: TMaxLogPalette;
  213.     function GetPalette: HPALETTE; override;
  214.     procedure WMPaletteChanged( var aMsg: TWMPaletteChanged ); message WM_PALETTECHANGED;
  215.   protected // -- Custom Draw Tree Page ----
  216.     procedure CDT_DoFontStyle( aNode: TTreeNode;  aDown: Boolean;  aStyle: TFontStyle );
  217.     function  CDT_GetNodeData( aNode: TTreeNode ): TTvData;
  218.     procedure CDT_OnDynamicMenuClick( aSender: TObject );
  219.   public
  220.     { Public declarations }
  221.   end;
  222.  
  223. var
  224.   FrmMain: TFrmMain;
  225.  
  226. implementation
  227. uses ShellApi,
  228.        FExplorer;
  229. {$R *.DFM}
  230.  
  231. {Create a blue-white wash palette with 64 entries}
  232. procedure CreatePaletteStruct( var lp: TMaxLogPalette );
  233. const ENTRIES = 64;
  234.   function PeEntry( r, g, b: Byte ): TPaletteEntry;
  235.   begin
  236.     result.peRed   := r;
  237.     result.peGreen := g;
  238.     result.peBlue  := b;
  239.     result.peFlags := 0;
  240.   end;
  241. var i: Integer;
  242.     tp: TColorRef;
  243.     bt: TColorRef;
  244.  
  245.     tr, tg, tb: Integer;
  246.     br, bg, bb: Integer;
  247. begin
  248.   lp.palVersion := $0300;
  249.   lp.palNumEntries := ENTRIES;
  250.  
  251.   tp := ColorToRGB( clBlue );      bt := ColorToRGB( clWhite );
  252.  
  253.   tr := GetRValue(tp);             br := GetRValue(bt);
  254.   tg := GetGValue(tp);             bg := GetGValue(bt);
  255.   tb := GetBValue(tp);             bb := GetBValue(bt);
  256.  
  257.   for i := 0 to ENTRIES-1 do
  258.     lp.palPalEntry[i] := PeEntry( tr + ((br-tr)*i) div (ENTRIES-1),
  259.                                   tg + ((bg-tg)*i) div (ENTRIES-1),
  260.                                   tb + ((bb-tb)*i) div (ENTRIES-1) );
  261. end; {CreatePaletteStruct}
  262.  
  263.  
  264. {---------------------------------------------------------}
  265.  
  266. constructor TTvData.Create( aFont: TFont;  aColor: TColor );
  267. begin
  268.   mFont := TFont.Create;
  269.   mFont.Assign( aFont );
  270.   mBkColor := aColor;
  271. end;
  272.  
  273. destructor TTvData.Destroy;
  274. begin
  275.   mFont.Free;
  276.   inherited;
  277. end;
  278.  
  279. procedure TTvData.SetFont( aValue: TFont );
  280.   begin mFont.Assign( aValue ); end;
  281.  
  282. {---------------------------------------------------------}
  283.  
  284.  
  285. procedure TFrmMain.Button1Click(Sender: TObject);
  286. begin
  287.   if not Assigned(FrmExplorer) then FrmExplorer := TFrmExplorer.Create(self);
  288.   FrmExplorer.Show;
  289. end;
  290.  
  291.  
  292. { Loads a rich text file from resources into the given rich text control. }
  293. procedure TFrmMain.LoadRtf( rtf: TRichEdit;  id: Integer );
  294. var rs: TResourceStream;
  295. begin
  296.   rs := TResourceStream.CreateFromId( HInstance, id, 'RTF' );
  297.   try rtf.Lines.LoadFromStream( rs ); finally rs.Free; end;
  298. end;
  299.  
  300.  
  301. function TFrmMain.GetPalette: HPALETTE;
  302. begin
  303.   result := mhPal;
  304. end;
  305.  
  306.  
  307. procedure TFrmMain.WMPaletteChanged( var aMsg: TWMPaletteChanged );
  308. begin
  309.   if (aMsg.PalChg <> PaintBox1.Parent.Handle) then
  310.     PaintBox1.Invalidate;
  311.   inherited;
  312. end;
  313.  
  314.  
  315. {$WARNINGS OFF}
  316. procedure Wash( aCanvas: TCanvas;  ahPalette: HPalette;  apPalStruct: PLogPalette;  afActive: Boolean;
  317.                 aRect: TRect;  aFrom, aTo: TColor;  afVertical: Boolean );
  318. type PColorRef=^TColorRef;
  319. var pPalStruct: PMaxLogPalette absolute apPalStruct;
  320.     i: Integer;
  321.     tp: TColorRef;
  322.     bt: TColorRef;
  323.  
  324.     tr, tg, tb: Integer;
  325.     br, bg, bb: Integer;
  326.  
  327.     rc: TRect;
  328.  
  329.     nDivs: Integer;
  330.  
  331.     oldpal: HPALETTE;
  332. begin
  333.   if (ahPalette=0) then
  334.   begin
  335.     tp := ColorToRGB( aFrom );      bt := ColorToRGB( aTo );
  336.     tr := GetRValue(tp);            br := GetRValue(bt);
  337.     tg := GetGValue(tp);            bg := GetGValue(bt);
  338.     tb := GetBValue(tp);            bb := GetBValue(bt);
  339.     if afVertical then
  340.       nDivs := (aRect.bottom - aRect.top) div 2 +1
  341.     else
  342.       nDivs := (aRect.right - aRect.left) div 2 +1;
  343.     rc := aRect;
  344.   end
  345.   else
  346.   begin
  347.     oldpal := SelectPalette( aCanvas.Handle, ahPalette, not afActive );
  348.     RealizePalette( aCanvas.Handle );
  349.     rc := aRect;
  350.     nDivs := 64;
  351.   end;
  352.  
  353.   with aCanvas do
  354.   begin
  355.     for i := 0 to nDivs-1 do
  356.     begin
  357.       if (ahPalette=0) then
  358.         Brush.Color := RGB( tr + ((br-tr)*i) div (nDivs-1),
  359.                             tg + ((bg-tg)*i) div (nDivs-1),
  360.                             tb + ((bb-tb)*i) div (nDivs-1) )
  361.       else
  362.         Brush.Color := $02000000 or PColorRef(@pPalStruct^.palPalEntry[i])^;
  363.       if afVertical then
  364.       begin
  365.         rc.top := ((aRect.bottom - aRect.top)*i) div nDivs;
  366.         rc.bottom := rc.top + (aRect.bottom - aRect.top) div nDivs+1;
  367.       end
  368.       else
  369.       begin
  370.         rc.left := aRect.left + ((aRect.right - aRect.left)*i) div nDivs;
  371.         rc.right := rc.Left + (aRect.right - aRect.left) div nDivs +1;
  372.       end;
  373.       FillRect( rc );
  374.     end;
  375.   end;
  376.  
  377.   if (ahPalette<>0) then
  378.     SelectPalette( aCanvas.Handle, oldpal, TRUE );
  379. end;
  380. {$WARNINGS ON}
  381.  
  382.  
  383. procedure TFrmMain.PaintBox1Paint(Sender: TObject);
  384. begin
  385.   Wash( PaintBox1.Canvas, mhPal, Pointer(@mPalStruct), Active, PaintBox1.ClientRect, clBlue, clWhite, TRUE );
  386. end;
  387.  
  388. procedure TFrmMain.OnNextBtnClick(Sender: TObject);
  389.   begin PageControl1.SelectNextPage(TRUE); end;
  390.  
  391. procedure TFrmMain.OnBackBtnClick(Sender: TObject);
  392.   begin PageControl1.SelectNextPage(FALSE); end;
  393.  
  394. procedure TFrmMain.Button10Click(Sender: TObject);
  395.   const PLASMATECH_URL = 'http://plasmatech.com';
  396.   begin ShellExecute( Handle, nil, PLASMATECH_URL, nil, nil, SW_SHOWNORMAL ); end;
  397.  
  398. procedure TFrmMain.OrderBtnClick(Sender: TObject);
  399.   const ORDER_URL = 'http://order.kagi.com/?J6&S';
  400.   begin ShellExecute( Handle, nil, ORDER_URL, nil, nil, SW_SHOWNORMAL ); end;
  401.  
  402. procedure TFrmMain.FormCreate(Sender: TObject);
  403. var imgl, imgl2: TImageList;
  404.   function IsPalettedDisplay: Bool;
  405.   var dc: HDC;
  406.   begin
  407.     dc := GetDC(0);
  408.     result := ((Windows.GetDeviceCaps(dc, Windows.RASTERCAPS) and RC_PALETTE) <> 0);
  409.     ReleaseDC(0,dc);
  410.   end;
  411.  
  412.   function GetIndexOfExt( ext: String ): Integer;
  413.   var shfi: TSHFileInfo;
  414.   begin
  415.     SHGetFileInfo( PChar(ext),0, shfi, Sizeof(TSHFileInfo), SHGFI_USEFILEATTRIBUTES or SHGFI_ICON );
  416.     result := shfi.iIcon
  417.   end;
  418.  
  419.   procedure AddIt( s: String;  idx, offs: Integer );
  420.   begin
  421.     PTImageCombo1.AddItem( s, idx, offs );
  422.     PTImageCombo2.AddItem( s, idx, offs );
  423.   end;
  424. var s: String;
  425. begin
  426.   Screen.Cursor := crHourglass;
  427.   try
  428.     PageControl1.ActivePage := WelcomeTsh;
  429.  
  430.    // Setup palette
  431.     if IsPalettedDisplay then
  432.     begin
  433.       CreatePaletteStruct( mPalStruct );
  434.       mhPal := Windows.CreatePalette( PLogPalette(@mPalStruct)^ );
  435.     end;
  436.  
  437.    // Load rich text
  438.     LoadRTF( OverviewRchtxt, 101 );
  439.     LoadRTF( ExplorerRchtxt, 102 );
  440.     LoadRTF( FileOpenRchedt, 103 );
  441.     LoadRTF( ShellGetDisplayPathnameRchedt, 104 );
  442.     LoadRTF( FolderBrowseRchedt, 105 );
  443.     LoadRTF( ImageComboRchedt, 106 );
  444.     LoadRTF( OrderRchedt, 107 );
  445.     LoadRTF( CustomDrawTreeRchedt, 108 );
  446.  
  447.    // Setup "Image Combo" Page
  448.     imgl := TImageList.Create(self);
  449.     imgl.ShareImages := TRUE;
  450.     imgl.Handle := ShellGetSystemImageList( ptsizLarge );
  451.     PTImageCombo1.ImageList := imgl;
  452.  
  453.     imgl2 := TImageList.Create(self);
  454.     imgl2.ShareImages := TRUE;
  455.     imgl2.Handle := ShellGetSystemImageList( ptsizSmall );
  456.     PTImageCombo2.ImageList := imgl2;
  457.  
  458.    // Just loading up the image combos with some arbitrary data
  459.     AddIt( 'Text file', GetIndexOfExt('.txt'), 0 );
  460.     AddIt( 'Document',  GetIndexOfExt('.doc'), 1 );
  461.     AddIt( 'HTML file', GetIndexOfExt('.htm'), 1 );
  462.     AddIt( 'Bitmap',    GetIndexOfExt('.bmp'), 2 );
  463.     AddIt( 'GIF image', GetIndexOfExt('.gif'), 1 );
  464.  
  465.     PTImageCombo1.ItemIndex := 0;
  466.     PTImageCombo2.ItemIndex := 1;
  467.  
  468.    // Setup "Custom Draw Tree" page
  469.     PTTreeView1.FullExpand;
  470.  
  471.    // Setup "Splitter Panels" page
  472.     Image3.Picture := PlasmaLogoImg.Picture;
  473.     with Image1.Picture.Bitmap do
  474.     begin
  475.       Width := ToolbarImg.Width;
  476.       Height := ToolbarImg.Height;
  477.       Canvas.Brush.Color := clBtnFace;
  478.       Canvas.BrushCopy( Rect(0,0,Width,Height), ToolbarImg.Picture.Bitmap, Rect(0,0,Width,Height), clFuchsia );
  479.     end;
  480.  
  481.    // Setup "Extra" page
  482.     UppercaseEdt.Text := AnsiUppercase(ParamStr(0));
  483.     GetDisplayEdt.Text := ShellGetDisplayPathname(UppercaseEdt.Text);
  484.  
  485.    //
  486.     s := VersionTxt.Caption;
  487.     if (PTSHELLCONTROLS_VERSION mod 100) <> 0 then
  488.     begin
  489.       s := Format(s, [Format('%.02f',[PTSHELLCONTROLS_VERSION/100])]);
  490.       if s[Length(s)]='0' then SetLength(s, Length(s)-1);
  491.     end
  492.     else
  493.       s := Format(s, [IntToStr(PTSHELLCONTROLS_VERSION div 100)]);
  494.     if (PTSHELLCONTROLS_PATCH > 0) then
  495.       s := s + Char(Ord('a')+PTSHELLCONTROLS_PATCH-1);
  496.     VersionTxt.Caption := s;
  497.     VersionTxt.Autosize := FALSE; VersionTxt.Autosize := TRUE; // Force label to autosize
  498.     VersionTxt.Left := (VersionTxt.Parent.ClientWidth - VersionTxt.Width) div 2;
  499.  
  500.     PTFolderBrowseDlg1.SelectedFolder.Pathname := GetCurrentDir;
  501.  
  502.     BaseTxt.Caption := 'Base is: '+ShellGetFriendlyNameFromIdList( nil, PTFolderBrowseDlg1.BaseFolder.IdList, ptfnNormal );
  503.  
  504.     PTTreeView1.OnPTCustomDraw := PTTreeView1PTCustomDraw;
  505.   finally
  506.     Screen.Cursor := Cursor;
  507.   end;
  508. end;
  509.  
  510. procedure TFrmMain.FormDestroy(Sender: TObject);
  511. begin
  512.   if (mhPal <> 0) then Windows.DeleteObject(mhPal);
  513. end;
  514.  
  515. procedure TFrmMain.TestOpenDlgBtnClick(Sender: TObject);
  516. var i, max: Integer;
  517.     s: String;
  518. begin
  519.   if PTOpenDlg1.Execute then
  520.     if PTOpenDlg1.Files.Count>0 then
  521.     begin
  522.       if PTOpenDlg1.Files.Count>1 then
  523.       begin
  524.         s := 'Multiselect'#13;
  525.         max := PTOpenDlg1.Files.Count-1;
  526.         if max>25 then max:=25;
  527.         for i := 0 to max do
  528.           s := s + PTOpenDlg1.Files[i] + #13;
  529.         if (max < PTOpenDlg1.Files.Count-1) then
  530.           s := s + '...';
  531.         ShowMessage( s );
  532.       end;
  533.       Edit1.Text := PTOpenDlg1.Files[0];
  534.     end;
  535. end;
  536.  
  537. procedure TFrmMain.Button13Click(Sender: TObject);
  538. begin
  539.   PTSaveDlg1.Execute;
  540. end;
  541.  
  542. procedure TFrmMain.FolderBrowseBtnClick(Sender: TObject);
  543. begin
  544.   PTFolderBrowseDlg1.Status := 'This is an example of the TPTFolderBrowseDlg component.';
  545.   if PTFolderBrowseDlg1.Execute then
  546.     ShowMessage( Format( 'You selected:'#13'  Filesystem Name: %s'#13'  Display Name: %s',
  547.                  [ PTFolderBrowseDlg1.SelectedPathname,
  548.                    ShellGetFriendlyNameFromIdList(nil, PTFolderBrowseDlg1.SelectedFolder.IdList, ptfnInFolder)] ) );
  549. end;
  550.  
  551. procedure TFrmMain.PTFolderBrowseDlg1SelChange(aSender: TObject; aNewSel: PItemIDList);
  552. begin
  553.   if Assigned(aNewSel) then
  554.     PTFolderBrowseDlg1.Status := ShellGetPathFromIdList(aNewSel)
  555.   else
  556.     PTFolderBrowseDlg1.Status := '';
  557. end;
  558.  
  559.  
  560. procedure TFrmMain.EnableTimerBtnClick(Sender: TObject);
  561. begin
  562.   EnableTimerBtn.Down := not Timer1.Enabled;
  563.   Timer1.Enabled := EnableTimerBtn.Down;
  564.   PTTreeView1.Invalidate;
  565. end;
  566.  
  567. var _lastpos: Integer = 0;
  568.     _lastposdelta: Integer = +1;
  569.  
  570. procedure TFrmMain.Timer1Timer(Sender: TObject);
  571. begin
  572.   PTTreeView1.InvalidateNode( PTTreeView1.Items[_lastPos], FALSE, TRUE );
  573.   _lastpos := _lastpos + _lastposdelta;
  574.   if (_lastpos > PTTreeView1.Items.Count-1) then
  575.   begin
  576.     _lastpos := PTTreeView1.Items.Count-2;
  577.     _lastposdelta := -1;
  578.   end
  579.   else if (_lastpos < 0) then
  580.   begin
  581.     _lastpos := 1;
  582.     _lastposdelta := +1;
  583.   end;
  584.   PTTreeView1.InvalidateNode( PTTreeView1.Items[_lastPos], FALSE, TRUE );
  585.   PTTreeView1.Update;
  586. end;
  587.  
  588.  
  589. procedure TFrmMain.PTTreeView1PTCustomDraw(aSender: TObject;
  590.   aCD: TPTCustomDraw; aNode: TTreeNode);
  591. begin
  592.   with CDT_GetNodeData(aNode) do
  593.   begin
  594.     aCD.Font := {.}Font;
  595.     if aNode.Selected or aNode.DropTarget then
  596.       if PTTreeView1.Focused then
  597.         aCD.Font.Color := clHighlightText // Use the default item color when it is selected (but still change the font)
  598.       else
  599.         aCD.Font.Color := clBtnText
  600.     else // Don't change the background color for selected items
  601.       aCD.Brush.Color := {.}BkColor;
  602.   end;
  603.  
  604.   if (Timer1.Enabled) then
  605.   begin
  606.     if aNode.AbsoluteIndex = _lastPos then
  607.     begin
  608.       aCD.NoDefaultDrawing := TRUE;
  609.       Wash( aCD.Canvas, mhPal, Pointer(@mPalStruct), Active, aNode.DisplayRect(FALSE), clBlue, clWhite, FALSE );
  610.     end
  611.   end
  612. end;
  613.  
  614. procedure TFrmMain.BoldBtnClick(Sender: TObject);
  615.   begin CDT_DoFontStyle( PTTreeView1.Selected, BoldBtn.Down, fsBold ); end;
  616.  
  617. procedure TFrmMain.ItalicBtnClick(Sender: TObject);
  618.   begin CDT_DoFontStyle( PTTreeView1.Selected, ItalicBtn.Down, fsItalic ); end;
  619.  
  620. procedure TFrmMain.UnderlineBtnClick(Sender: TObject);
  621.   begin CDT_DoFontStyle( PTTreeView1.Selected, UnderlineBtn.Down, fsUnderline ); end;
  622.  
  623. procedure TFrmMain.PTTreeView1Deletion(Sender: TObject; Node: TTreeNode);
  624.   begin if Assigned(Node.Data) then TObject(Node.Data).Free; end;
  625.  
  626. procedure TFrmMain.CDT_DoFontStyle( aNode: TTreeNode;  aDown: Boolean;  aStyle: TFontStyle );
  627. begin
  628.   if not Assigned(aNode) then Exit;
  629.   with CDT_GetNodeData(aNode).Font do
  630.   begin
  631.     if aDown then
  632.       Style := Style + [aStyle]
  633.     else
  634.       Style := Style - [aStyle];
  635.     PTTreeView1.InvalidateNode( aNode, FALSE, TRUE );
  636.     PTTreeView1.Refresh;
  637.   end;
  638. end;
  639.  
  640. function  TFrmMain.CDT_GetNodeData( aNode: TTreeNode ): TTvData;
  641. begin
  642.   if not Assigned(aNode.Data) then
  643.     aNode.Data := TTvData.Create(PTTreeView1.Font, PTTreeView1.Color);
  644.   result := aNode.Data;
  645. end;
  646.  
  647. procedure TFrmMain.CDT_OnDynamicMenuClick( aSender: TObject );
  648.   begin ShowMessage( 'You clicked "' + (aSender as TMenuItem).Caption + '"' ); end;
  649.  
  650. procedure TFrmMain.FontBtnClick(Sender: TObject);
  651. begin
  652.   if Assigned(PTTreeView1.Selected) and Assigned(PTTreeView1.Selected.Data) then
  653.     if FontDialog1.Execute then
  654.     begin
  655.       CDT_GetNodeData(PTTreeView1.Selected).Font := FontDialog1.Font;
  656.       PTTreeView1.InvalidateNode( PTTreeView1.Selected, FALSE, TRUE );
  657.     end;
  658. end;
  659.  
  660. procedure TFrmMain.FgColorBtnClick(Sender: TObject);
  661. begin
  662.   if Assigned(PTTreeView1.Selected) and Assigned(PTTreeView1.Selected.Data) then
  663.     with CDT_GetNodeData( PTTreeView1.Selected ) do
  664.     begin
  665.       ColorDialog1.Color := {.}Font.Color;
  666.       if ColorDialog1.Execute then
  667.         {.}Font.Color := ColorDialog1.Color;
  668.     end;
  669. end;
  670.  
  671. procedure TFrmMain.BkColorBtnClick(Sender: TObject);
  672. begin
  673.   if Assigned(PTTreeView1.Selected) and Assigned(PTTreeView1.Selected.Data) then
  674.     with CDT_GetNodeData( PTTreeView1.Selected ) do
  675.     begin
  676.       ColorDialog1.Color := {.}BkColor;
  677.       if ColorDialog1.Execute then
  678.         {.}BkColor := ColorDialog1.Color;
  679.     end;
  680. end;
  681.  
  682. procedure TFrmMain.ClickMe1BtnClick(Sender: TObject);
  683.   procedure SetItem( aNode: TTreeNode; afs: TFontStyles; aclr, abkclr: TColor );
  684.   begin
  685.     with CDT_GetNodeData(aNode) do
  686.     begin
  687.       Font.Style := afs;
  688.       Font.Color := aclr;
  689.       BkColor := abkclr;
  690.     end;
  691.   end;
  692.  
  693. type TRec = record
  694.        styles: TFontStyles;
  695.        fgclr: TColor;
  696.        bkclr: TColor
  697.      end;
  698.  
  699. const NR: array[0..6] of TRec = (
  700.         (styles: [fsBold];       fgclr: clBlue;           bkclr: clWhite            ), // Fruit
  701.         (styles: [];             fgclr: clYellow;         bkclr: clRed              ), // Apple
  702.         (styles: [];             fgclr: clGreen;          bkclr: clYellow           ), // Pear
  703.         (styles: [fsStrikeout];  fgclr: clWhite;          bkclr: clGreen            ), // Guava
  704.         (styles: [fsBold];       fgclr: clGreen;          bkclr: clWhite            ), // Dogs
  705.         (styles: [fsItalic];     fgclr: clWindowText;     bkclr: clWindow           ), // Shih Tzu
  706.         (styles: [fsItalic];     fgclr: clGray;           bkclr: clWindow           )  // Jack Russel
  707.       );
  708.  
  709. var i: Integer;
  710. begin
  711.   for i := Low(NR) to High(NR) do
  712.     with NR[i] do
  713.       SetItem( PTTreeView1.Items[i], styles, fgclr, bkclr );
  714.   PTTreeView1.Invalidate;
  715. end;
  716.  
  717. procedure TFrmMain.ResetBtnClick(Sender: TObject);
  718. var i: Integer;
  719. begin
  720.   for i := 0 to PTTreeView1.Items.Count-1 do
  721.     with CDT_GetNodeData(PTTreeView1.Items[i]) do
  722.     begin
  723.       Font := PTTreeView1.Font;
  724.       BkColor := PTTreeView1.Color;
  725.     end;
  726.   PTTreeView1.Invalidate;
  727. end;
  728.  
  729. procedure TFrmMain.ViewMitmClick(Sender: TObject);
  730. var i: Integer;
  731. begin
  732.   for i := 0 to PopupMenu1.Items.Count-1 do // Delphi 2 needs this
  733.     PopupMenu1.Items[i].Checked := FALSE;
  734.  
  735.   with (Sender as TMenuItem) do
  736.   begin
  737.     PTShellList1.ViewStyle := TViewStyle( {.}Tag );
  738.     {.}Checked := TRUE;
  739.   end;
  740. end;
  741.  
  742. var gUniqueId: Integer = 0;
  743.  
  744. procedure TFrmMain.PTTreeView1NodeContextMenu(aSender: TObject;
  745.   aNode: TTreeNode; var aPos: TPoint; var aMenu: TPopupMenu);
  746. var m: TPopupMenu;
  747. begin
  748.   aMenu := nil;
  749.  
  750.   m := NewPopupMenu( self, Format('Menu%d',[gUniqueId]), paLeft, FALSE, [
  751.     NewItem(aNode.Text, 0, FALSE, TRUE, CDT_OnDynamicMenuClick, 0, Format('MItem%d',[gUniqueId])) ] );
  752.   Inc( gUniqueId );
  753.  
  754.   try
  755.     with PTTreeView1.ClientToScreen(aPos) do
  756.     begin
  757.       SendCancelMode(nil);
  758.       m.PopupComponent := PTTreeView1;
  759.       m.Popup( x, y );
  760.       Application.ProcessMessages;
  761.         // If you free the menu before messages get processed, which we do, you should call this first. Be aware
  762.         // that by calling ProcessMessages, this event procedure could be re-entered.
  763.     end;
  764.   finally
  765.     m.Free;
  766.   end;
  767. end;
  768.  
  769. procedure TFrmMain.PTTreeView1Change(Sender: TObject; Node: TTreeNode);
  770. var bv, iv, uv: Boolean;
  771. begin
  772.   bv:=FALSE; iv:=FALSE; uv:=FALSE;
  773.   if Assigned(Node) and Assigned(Node.Data) then
  774.     with CDT_GetNodeData(Node) do
  775.     begin
  776.       bv := fsBold in Font.Style;
  777.       iv := fsItalic in Font.Style;
  778.       uv := fsUnderline in Font.Style;
  779.     end;
  780.   BoldBtn.Down := bv;
  781.   ItalicBtn.Down := iv;
  782.   UnderlineBtn.Down := uv;
  783. end;
  784.  
  785. procedure TFrmMain.BaseBtnClick(Sender: TObject);
  786. var f: TPTFolderBrowseDlg;
  787. begin
  788.   f := TPTFolderBrowseDlg.Create( self );
  789.   try
  790.     f.Status := 'Select a folder to act as base folder.';
  791.     f.SelectedFolder := PTFolderBrowseDlg1.BaseFolder;
  792.     if f.Execute then
  793.     begin
  794.       PTFolderBrowseDlg1.BaseFolder := f.SelectedFolder;
  795.       BaseTxt.Caption := 'Base is: '+ShellGetFriendlyNameFromIdList( nil, f.SelectedFolder.IdList, ptfnNormal );
  796.       PTFolderBrowseDlg1.SelectedFolder := f.SelectedFolder;
  797.     end;
  798.   finally
  799.     f.Free;
  800.   end;
  801. end;
  802.  
  803. procedure TFrmMain.ToolbarImgMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  804. const ComponentNames: array[0..13] of String = (
  805.         'TPTShellTree'#13#13'Enhanced Explorer tree view.',
  806.         'TPTShellList'#13#13'Enhanced Explorer list view.',
  807.         'TPTShellCombo'#13#13'Explorer combo box.',
  808.         'TPTOpenDlg'#13#13'Powerful replacement for TOpenDlg.',
  809.         'TPTSaveDlg'#13#13'Powerful replacement for TSaveDlg.',
  810.         'TPTFolderBrowseDlg'#13#13'Powerful replacement for SHBrowseForFolder.',
  811.         'TPTFrame'#13#13'Non-windowed frame control with 11 frame styles.',
  812.         'TPTGroup'#13#13'Windowed TPanel replacement with 11 frame styles.',
  813.         'TPTSplitter'#13#13'Powerful and simple splitter control.',
  814.         'TPTImageCombo'#13#13'Combo box with image and indent'#13'level per item.',
  815.         'TPTSysFolderDlg'#13#13'Encapsulation of the system''s'#13'built-in SHBrowseForFolder function.',
  816.         'TPTCombobox'#13#13'Combo box control with events for'#13'OnDeleteItem, OnCloseUp, OnSelEndOk and OnSelEndCancel.',
  817.         'TPTTreeView'#13#13'Enhanced tree view control with Internet Explorer 3/4 features.',
  818.         'TPTListView'#13#13'Enhanced list view control with Internet Explorer 3/4 features.'
  819.       );
  820. var item: Integer;
  821. begin
  822.   item := (x-8) div 28;
  823.   if (item < Low(ComponentNames)) or (item > High(ComponentNames)) then
  824.   begin
  825.     Application.CancelHint;
  826.     ToolbarImg.Hint := '';
  827.   end
  828.   else
  829.   begin
  830.     if ToolbarImg.Hint <> ComponentNames[item] then
  831.     begin
  832.       Application.CancelHint;
  833.       ToolbarImg.Hint := ComponentNames[item];
  834.     end;
  835.   end;
  836. end;
  837.  
  838.  
  839. end.
  840.  
  841.